home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / rmail / rmail-kill.el.z / rmail-kill.el
Encoding:
Text File  |  1998-05-21  |  6.1 KB  |  159 lines
  1. ;;; rmail-kill.el --- Mail filtering for rmail
  2.  
  3. ;; Copyright status unknown
  4.  
  5. ;; Author: Unknown
  6. ;; Keywords: mail
  7.  
  8. ;; This file is part of XEmacs.
  9.  
  10. ;; XEmacs is free software; you can redistribute it and/or modify it
  11. ;; under the terms of the GNU General Public License as published by
  12. ;; the Free Software Foundation; either version 2, or (at your option)
  13. ;; any later version.
  14.  
  15. ;; XEmacs is distributed in the hope that it will be useful, but
  16. ;; WITHOUT ANY WARRANTY; without even the implied warranty of
  17. ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  18. ;; General Public License for more details.
  19.  
  20. ;; You should have received a copy of the GNU General Public License
  21. ;; along with XEmacs; see the file COPYING.  If not, write to the Free
  22. ;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
  23. ;; 02111-1307, USA.
  24.  
  25. ;;; Synched up with: Not in FSF.
  26.  
  27. ;;; Commentary:
  28. ;; This is the Original Notice on this file:
  29. ;; GNU Emacs and this file "rmail-kill.el", is distributed in the hope
  30. ;; that it will be useful, but WITHOUT ANY WARRANTY.  No author or
  31. ;; distributor accepts responsibility to anyone for the consequences
  32. ;; of using it or for whether it serves any particular purpose or
  33. ;; works at all, unless he says so in writing.  Refer to the GNU Emacs
  34. ;; General Public License for full details.
  35.  
  36. ;; Everyone is granted permission to copy, modify and redistribute GNU
  37. ;; Emacs and rmail-kill.el, but only under the conditions described in
  38. ;; the GNU Emacs General Public License.  A copy of this license is
  39. ;; supposed to have been given to you along with GNU Emacs so you can
  40. ;; know your rights and responsibilities.  It should be in a file
  41. ;; named COPYING.  Among other things, the copyright notice and this
  42. ;; notice must be preserved on all copies.
  43.  
  44. ;;; Code:
  45. (setq rmail-message-filter 'rmail-maybe-execute-message
  46.       rmail-mode-hook '((lambda ()
  47.               (define-key rmail-mode-map "e" 'rmail-extract-rejected-message)
  48.               (define-key rmail-mode-map "b" 'rmail-beginning-of-message)
  49.               (define-key rmail-mode-map "K" 'rmail-execute-messages))))
  50.  
  51. ;; a-list with each entry (rmail-field-name . pattern)
  52. (defvar rmail-usual-suspects
  53.   '(("subject" . "Smithsonian Astronomical Observatory")
  54.     ("subject" . "MGR, Bellcore window manager, Part"))
  55.   "An alist used to kill rmail messages based on regex matches to different fields.
  56. The car of each entry is the name of a mail header, the cdr is a pattern.
  57. Case is not significant.)
  58.  
  59. See also the documentation for rmail-maybe-execute-message and
  60. rmail-execute-messages.")
  61.  
  62. (setq kill-emacs-hook 'maybe-book-some-suspects)
  63.  
  64. (defun maybe-book-some-suspects ()
  65.   (save-window-excursion
  66.     (find-file "~/.emacs")
  67.     (goto-char (point-min))
  68.     (re-search-forward "^(defvar rmail-usual-suspects$")
  69.     (down-list 1)
  70.     (backward-char 1)
  71.     (if (not (equal rmail-usual-suspects
  72.             (save-excursion (read (current-buffer)))))
  73.     (progn
  74.       (switch-to-buffer-other-window "SUSPECTS")
  75.       (erase-buffer)
  76.       (mapcar '(lambda (x) (print x (current-buffer)))
  77.           rmail-usual-suspects)
  78.       (set-buffer-modified-p nil)
  79.       (if (y-or-n-p "Save the usual suspects? ")
  80.           (progn
  81.         (set-buffer ".emacs")
  82.         (kill-sexp 1)
  83.         (prin1 rmail-usual-suspects (get-buffer ".emacs"))
  84.         (save-buffer)))))))
  85.  
  86. (defun rmail-maybe-execute-message (&optional suspects dont-move)
  87.   "Kill the current message if it matches an entry in SUSPECTS.
  88. SUSPECTS is alist of the form of rmail-usual-suspects (which see).
  89. If the current message contains a mail header that matches pattern,
  90. it is deleted.
  91.  
  92. This function can be used as a rmail-message-filter (which see)."
  93.   (if (null suspects)
  94.       (setq suspects rmail-usual-suspects))
  95.   (while suspects
  96.     (if (and (string-match (cdr (car suspects))
  97.                ;; if not such field, can never match
  98.                (or (mail-fetch-field (car (car suspects))) "$^"))
  99.          (not (rmail-message-deleted-p rmail-current-message)))
  100.     (progn
  101.       (message "Deleted message %d" rmail-current-message)
  102.       (if dont-move
  103.           (rmail-delete-message)
  104.         (rmail-delete-forward))
  105.       (setq suspects nil))
  106.       (setq suspects (cdr suspects)))))
  107.  
  108. (defun rmail-execute-messages (round-up-the-usual-suspects)
  109.   "Kill some rmail messages based on regex matches to a kill-alist.
  110. With a prefix arg, use rmail-usual-suspects as the kill-alist, otherwise
  111. prompt for a field name."
  112.   (interactive "P")
  113.   (let ((scene-of-the-crime rmail-current-message)
  114.     (alleged-perpetrator)
  115.     (cuffed-all-suspects nil))
  116.     (if round-up-the-usual-suspects
  117.     (setq alleged-perpetrator rmail-usual-suspects)
  118.       (let* ((weapon (rmail-get-current-header "Kill what field? (default Subject) " "Subject"))
  119.          (default-description (or (regexp-quote (mail-fetch-field weapon))
  120.                       "some regex"))
  121.          (most-wanted-notice (format "Kill messages having a \"%s\" field matching? (default %s) "
  122.                      weapon default-description))
  123.          (suspect-description (read-string-with-default most-wanted-notice default-description)))
  124.     (setq alleged-perpetrator (list (cons weapon suspect-description)))
  125.     (if (y-or-n-p "Add it to rmail-usual-suspects? ")
  126.         (setq rmail-usual-suspects (append alleged-perpetrator rmail-usual-suspects)))))
  127.  
  128.     (while (not cuffed-all-suspects)
  129.       (rmail-maybe-execute-message alleged-perpetrator 'dont-move)
  130.       ;;
  131.       ;; rmail-next-undeleted-message returns a string when there are no more, but
  132.       ;; we also want a chance to delete that last message...
  133.       ;;
  134.       (if (stringp alleged-perpetrator)
  135.       (setq cuffed-all-suspects t)
  136.     (setq cuffed-all-suspects (rmail-next-undeleted-message 1))))
  137.  
  138.     (rmail-show-message scene-of-the-crime)
  139.     (if (rmail-message-deleted-p rmail-current-message)
  140.     (rmail-next-undeleted-message 1))
  141.     (if (rmail-message-deleted-p rmail-current-message)
  142.     (rmail-previous-undeleted-message 1))))
  143.  
  144. (defun rmail-get-current-header (prompt default)
  145.   (save-excursion
  146.     (let* ((end (progn (end-of-line) (point))))
  147.       (beginning-of-line)
  148.       (if (re-search-forward "^\\([^ \t]*\\):" end t)
  149.       (buffer-substring (match-beginning 1) (match-end 1))
  150.     (read-string-with-default prompt default)))))
  151.  
  152. (defun read-string-with-default (prompt default)
  153.   (let ((s (read-string prompt)))
  154.     (if (string= s "") default s)))
  155.  
  156. (provide 'rmail-kill)
  157.  
  158. ;;; rmail-kill.el ends here
  159.